C       PROGRAM EXA4
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     Main of Example 4                       /
C/      Date-written.   Feb. 2nd 1984                           /
C/      File-name.      EXA4.FOR                                /
C/      Remarks.        Example-4 Simulation of a Drive-in Bank /
C/                      Simulation with GASP page 146.          /
C/                                                              /
C////////////////////////////////////////////////////////////////
        CHARACTER*12    FILE
        DIMENSION       NSET(6,25)
C       
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C

      DATA    XL,XMU,XBUZ,XISYS/0.4,1.0,1.0,1.0,1.0,6.0/
C
C       --- Set NCRDR equal to the Floppy drive number and
C           NPRNT to the printer number.
C
        NCRDR = 10
C
        IDRIVE = 0
        WRITE(1,90)
   90   FORMAT(1H0,'Output GASP data file to Display(1) or Printer(4)'
     1         /1H ,'Output Device number 1 or 4: ')  
        READ(1,95) NPRNT
   95      FORMAT(I1)
        WRITE(1,100)
  100     FORMAT(1H0,'Input GASP data file name (max 12 characters):')
        READ(1,200) FILE
  200     FORMAT(A0)
        WRITE(1,210) FILE
  210     FORMAT(1H ,'Input GASP data file name : ',A0)
        IF (IOREAD(NCRDR,MODE,IDRIVE,FILE)) GO TO 300
C
        WRITE(1,1000) XL,XMU(1),XMU(2),XBUZ(1),XBUZ(2),XISYS
 1000     FORMAT(1H ,6F10.2)
C
C       --- Initailize number of customers balking (CBALK), total
C           customers arriving (TCUST), and time last departure
C           (TLD) at 0.
C
        CBALK = 0.0
        TCUST = 0.0
        TLD = 0.0
        CALL    GASP(NSET)
        				GO TO 500
  300   WRITE(1,400) 'OPEN OR READ ERROR AT MAIN_PROGRAM '
  400     FORMAT(' ',A0)
  500   CALL    EXIT
        END
C
        SUBROUTINE      ARRVL(NSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     ARRVL                                   /
C/      Date-written.   Jan. 24th 1984                          /
C/      File-name.      ARRVL4.FOR                              /
C/      Remarks.        Subroutine ARRVL page 148               /
C/                      The arrival of items to the system is   /
C/                      described in terms of the time between  /
C/                      the arrivals, every arrival event must  /
C/                      cause the next arrival event to occur.  /
C/                      This is for Example-4 version.          /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        DIMENSION       NSET(6,25)
       
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C
C       --- Cause next arrival to occur
C
        CALL    DRAND(ISEED,RNUM)
        ATRIB(1) = TNOW - XL * ALOG(RNUM)
        ATRIB(3) = ATRIB(1)
        ATRIB(2) = 1.0
        CALL    FILEM(1,NSET)
C
C       --- Increment total customers arriving
C
        TCUST = TCUST + 1.0
C
C       --- Test to see if system in full
C
        IF (XISYS - 8.0) 2,1,1
C
C       --- System in full. increment number of balkers
C
    1   CBALK = CBALK + 1.0
        RETURN
    2   CALL    TMST(XISYS,TNOW,3,NSET)
C       --- Increment number in system
C
        XISYS = XISYS + 1.0
C
C       ---Set arrival time of this customer to TNOW
C
        ATRIB(3) = TNOW
C
C       --- Test to see if either server is free
C
        IF (XBUZ(1)) 15,4,3
    3   IF (XBUZ(2)) 15,5,7
    4   J = 1
        				GO TO 6
    5   J = 2
C
C       --- Assign arriving customer to free server.
C
   6    CALL    DRAND(ISEED,RNUM)
        ATRIB(1) = TNOW - XMU(J) * ALOG(RNUM)
        ATRIB(2) = J + 1
        CALL    FILEM(1,NSET)
        CALL    TMST(XBUZ(J),TNOW,J,NSET)
C
C       --- Set assigned server to busy status
C
        XBUZ(J) = 1.0
        RETURN
C
C       ---Both server are busy. Put customer in shorter queue.
C
    7   ATRIB(4) = TNOW
        IF (NQ(2) - NQ(3)) 8,8,9
    8   CALL    FILEM(2,NSET)
        				GO TO 10
    9   CALL    FILEM(3,NSET)
   10   RETURN
   15   CALL    ERROR(87,NSET)
        CALL    EXIT
        END
C
        SUBROUTINE      EVNTS(IX,NSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     EVNTS                                   /
C/      Date-written.   Jan. 24th 1984                          /
C/      File-name.      EVNTS4.FOR                              /
C/      Remarks.        Subroutine EVNTS page 146               /
C/                      Event code 1 siginifires an arrival     /
C/                      event; event code 2 signifires an end   /
C/                      of service event;                       /
C/                      and event code 3 signifires an end of   /
C/                      simulation event.                       /
C/                      User subroutine for Example-4.          /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        DIMENSION       NSET(6,25)
       
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C
C
        GO TO (1,2,2,3),IX
    1   CALL    ARRVL(NSET)
        RETURN
    2   CALL    ENDSV(NSET)
        RETURN
    3   CALL    ENDSM(NSET)
        RETURN
        END
C
        SUBROUTINE      ENDSM(NSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     ENDSM                                   /
C/      Date-written.   Jan. 26th 1984                          /
C/      File-name.      ENDSM4.FOR                              /
C/      Remaeks.        User defined subroutine, the completion /
C/                      of the simulation at a time specified   /
C/                      by the programmer.                      /
C/                      page 152.                               /
C/                      This is for Example-4 version.          /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        DIMENSION       NSET(6,25)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C
C
C       --- Update time ststistics for last time segment
C
        CALL    TMST(XBUZ(1),TNOW,1,NSET)
        CALL    TMST(XBUZ(2),TNOW,2,NSET)
        CALL    TMST(XISYS,TNOW,3,NSET)
        MSTOP = -1
        NORPT = 0
        RETURN
        END
C
        SUBROUTINE      ENDSV(NSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     ENDSV                                   /
C/      Date-written.   Jan. 26th 1984                          /
C/      File-name.      ENDSV4.FOR                              /
C/      Remarks.        Subroutine ENDSV page 151               /
C/                      In ENDSV(End_of_Service) it is first    /
C/                      necessary to collect statiscal infor-   /
C/                      mation about the item completing        /
C/                      processing.                             /
C/                      This is for Examle-4 version.           /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        DIMENSION       NSET(6,25)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C
C
C       --- Service is completed. Decrement number in system.
C           Collect ststistics on customer time in system and 
C           time between departure.
C
        CALL    TMST(XISYS,TNOW,3,NSET)
        XISYS = XISYS - 1.0
        TISYS = TNOW - ATRIB(3)
        CALL    COLCT(TISYS,1,NSET)
        TBD = TNOW - TLD
        TLD = TNOW
        CALL    COLCT(TBD,2,NSET)
C
C       --- J = number of queue of server with completed service.
C           M = server number, K = number of queue of the other server
C
        J = JEVNT
        M = J - 1
        IF (J - 2) 15,2,3
    2   K = 3
        				GO TO 1
    3   K = 2
    1   IF (NQ(J)) 15,4,6
    4   IF (NQ(K)) 15,5,9
    5   CALL    TMST(XBUZ(M),TNOW,M,NSET)
        XBUZ(M) = 0.0
        RETURN
C
C       --- Put first customer of queue J in service
C
    6   CALL    RMOVE(MFE(J),J,NSET)
C
C       --- Cause end of service event
C
   10   CALL    DRAND(ISEED,RNUM)
        ATRIB(1) = TNOW - XMU(M) * ALOG(RNUM)
        ATRIB(2) = J
        CALL    FILEM(1,NSET)
C
C       --- Test difference in queue length to determine if 
C           jockeying to take place
C
        IF (NQ(K) - NQ(J) - 2) 7,8,8
    7   RETURN
    8   CALL    RMOVE(MLE(K),K,NSET)
        ATRIB(4) = TNOW
        CALL    FILEM(J,NSET)
        RETURN
C
C       --- Since queue of server M is empty, last customer in queue
C           of other server is served by M
C
    9   CALL    RMOVE(MLE(K),K,NSET)
        				GO TO 10
   15   CALL    ERROR(86,NSET)
        CALL    EXIT
        END
C
        SUBROUTINE      OTPUT(NSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     OTPUT                                   /
C/      Date-written.   Jan. 26th 1984                          /
C/      File-name.      OTPUT4.FOR                              /
C/      Remarks.        Subroutine OTPUT.FOR page 152           /
C/                      Written by a programmer to perform      /
C/                      calculations and provide additional     /
C/                      output at the end of a simulation run.  /
C/                      This is the version for Example-4.	/
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        DIMENSION       NSET(6,25)
C       
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
     2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
C
      COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
     1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
     3		 NDAY,NYR,JCLR
C
      COMMON /C3/ XL,XMU(2),XBUZ(2),XISYS,CBALK,TCUST,TLD
C
C
        WRITE(NPRNT,10) XL,XMU(1),XMU(2)
   10     FORMAT(/25X,'Mean time between arrivals  =  ',F5.2/25X,
     1  	'Mean service time for tellers = ',F5.2,2X,F5.2)
        YBALK = CBALK * 100.0 / TCUST
        WRITE(NPRNT,20) YBALK,CBALK,TCUST
   20     FORMAT(25X,'Percent of customers balking = ',F6.2,' %'/,
     1           25X,'Number of customers balking =  ',F6.2/,25X,
     2          'Total customers',14X,'= ',F6.2)
        RETURN
        END
